Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue37/Alfresco/SortFns.pas

Pascal/Delphi Source File | 1998-07-27 | 11.7 KB | 363 lines

{*********************************************************}
{* SortFns                                               *}
{* Copyright (c) Julian M Bucknall 1998                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Sort routines                                         *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit SortFns;

interface

uses
  StdCtrls,
  SysUtils;

type
  TSortElement = double;

  TLessFunction = function (const X, Y : TSortElement) : boolean;
    {function prototype to compare two items and return true if item X
     is STRICTLY LESS than item Y}

procedure BubbleSort(var aItemArray    : array of TSortElement;
                         aLeft, aRight : integer;
                         aLessThan     : TLessFunction);

procedure ShakerSort(var aItemArray    : array of TSortElement;
                         aLeft, aRight : integer;
                         aLessThan     : TLessFunction);

procedure SelectionSort(var aItemArray    : array of TSortElement;
                            aLeft, aRight : integer;
                            aLessThan     : TLessFunction);

procedure InsertionSort(var aItemArray    : array of TSortElement;
                            aLeft, aRight : integer;
                            aLessThan     : TLessFunction);

procedure ShellSort(var aItemArray    : array of TSortElement;
                        aLeft, aRight : integer;
                        aLessThan     : TLessFunction);

procedure QuickSort(var aItemArray    : array of TSortElement;
                        aLeft, aRight : integer;
                        aLessThan     : TLessFunction);

procedure UsualInsertionSort(var aItemArray    : array of TSortElement;
                                 aLeft, aRight : integer;
                                 aLessThan     : TLessFunction);

procedure UsualQuickSort(var aItemArray    : array of TSortElement;
                             aLeft, aRight : integer;
                             aLessThan     : TLessFunction);

implementation

procedure BubbleSort(var aItemArray    : array of TSortElement;
                         aLeft, aRight : integer;
                         aLessThan     : TLessFunction);
var
  i, j : integer;
  Temp : TSortElement;
begin
  for i := aLeft to pred(aRight) do
    for j := aRight downto succ(i) do
      if aLessThan(aItemArray[j], aItemArray[j-1]) then begin
        Temp := aItemArray[j];
        aItemArray[j] := aItemArray[j-1];
        aItemArray[j-1] := Temp;
      end;
end;

procedure ShakerSort(var aItemArray    : array of TSortElement;
                         aLeft, aRight : integer;
                         aLessThan     : TLessFunction);
var
  i : integer;
  Temp : TSortElement;
begin
  while (aLeft < aRight) do begin
    for i := aRight downto succ(aLeft) do
      if aLessThan(aItemArray[i], aItemArray[i-1]) then begin
        Temp := aItemArray[i];
        aItemArray[i] := aItemArray[i-1];
        aItemArray[i-1] := Temp;
      end;
    inc(aLeft);
    for i := succ(aLeft) to aRight do
      if aLessThan(aItemArray[i], aItemArray[i-1]) then begin
        Temp := aItemArray[i];
        aItemArray[i] := aItemArray[i-1];
        aItemArray[i-1] := Temp;
      end;
    dec(aRight);
  end;
end;

procedure SelectionSort(var aItemArray    : array of TSortElement;
                            aLeft, aRight : integer;
                            aLessThan     : TLessFunction);
var
  i, j : integer;
  IndexOfMin : integer;
  Temp : TSortElement;
begin
  for i := aLeft to pred(aRight) do begin
    IndexOfMin := i;
    for j := succ(i) to aRight do
      if aLessThan(aItemArray[j], aItemArray[IndexOfMin]) then
        IndexOfMin := j;
    Temp := aItemArray[i];
    aItemArray[i] := aItemArray[IndexOfMin];
    aItemArray[IndexOfMin] := Temp;
  end;
end;

procedure UsualInsertionSort(var aItemArray    : array of TSortElement;
                                 aLeft, aRight : integer;
                                 aLessThan     : TLessFunction);
var
  i, j : integer;
  Temp : TSortElement;
begin
  for i := succ(aLeft) to aRight do begin
    Temp := aItemArray[i];
    j := i;
    while (j > aLeft) and aLessThan(Temp, aItemArray[j-1]) do begin
      aItemArray[j] := aItemArray[j-1];
      dec(j);
    end;
    aItemArray[j] := Temp;
  end;
end;

procedure InsertionSort(var aItemArray    : array of TSortElement;
                            aLeft, aRight : integer;
                            aLessThan     : TLessFunction);
var
  i, j : integer;
  IndexOfMin : integer;
  Temp : TSortElement;
begin
  {find the smallest element and put it in the first position}
  IndexOfMin := aLeft;
  for i := succ(aLeft) to aRight do
    if aLessThan(aItemArray[i], aItemArray[IndexOfMin]) then
      IndexOfMin := i;
  if (aLeft <> IndexOfMin) then begin
    Temp := aItemArray[aLeft];
    aItemArray[aLeft] := aItemArray[IndexOfMin];
    aItemArray[IndexOfMin] := Temp;
  end;
  {now sort via insertion method}
  for i := aLeft+2 to aRight do begin
    Temp := aItemArray[i];
    j := i;
    while aLessThan(Temp, aItemArray[j-1]) do begin
      aItemArray[j] := aItemArray[j-1];
      dec(j);
    end;
    aItemArray[j] := Temp;
  end;
end;

procedure ShellSort(var aItemArray    : array of TSortElement;
                        aLeft, aRight : integer;
                        aLessThan     : TLessFunction);
var
  i, j : integer;
  h    : integer;
  Temp : TSortElement;
begin
  {firstly calculate the first h value we shall use: it'll be about
   one ninth of the number of the elements}
  h := 1;
  while (h <= (aRight - aLeft) div 9) do
    h := (h * 3) + 1;
  {start a loop that'll decrement h by one third each time through}
  while (h > 0) do begin
    {now insertion sort each h-subfile}
    for i := (aLeft + h) to aRight do begin
      Temp := aItemArray[i];
      j := i;
      while (j >= (aLeft+h)) and aLessThan(Temp, aItemArray[j-h]) do begin
        aItemArray[j] := aItemArray[j-h];
        dec(j, h);
      end;
      aItemArray[j] := Temp;
    end;
    {decrease h by a third}
    h := h div 3;
  end;
end;

procedure UsualQuickSort(var aItemArray    : array of TSortElement;
                             aLeft, aRight : integer;
                             aLessThan     : TLessFunction);
  function Partition(L, R : integer): integer;
  var
    i, j : integer;
    Last : TSortElement;
    Temp : TSortElement;
  begin
    {set up the indexes}
    i := L;
    j := pred(R);
    {get the partition element}
    Last := aItemArray[R];
    {do forever (we'll break out of the loop when needed)}
    while true do begin
      {find the first element greater than or equal to the partition
       element from the left; note that our partition element will
       stop this loop}
      while aLessThan(aItemArray[i], Last) do
        inc(i);
      {find the first element less than the partition element from the
       right; check to break out of the loop if we hit the left
       element - we have no sentinel there}
      while aLessThan(Last, aItemArray[j]) do begin
        if (j = L) then
          Break;
        dec(j);
      end;
      {if we crossed get out of this infinite loop to swap the
       partition element into place}
      if (i >= j) then
        Break;
      {otherwise swap the two out-of-place elements}
      Temp := aItemArray[i];
      aItemArray[i] := aItemArray[j];
      aItemArray[j] := Temp;
      {and continue}
      inc(i);
      dec(j);
    end;
    {swap the partition element into place, return the dividing index}
    aItemArray[R] := aItemArray[i];
    aItemArray[i] := Last;
    Result := i;
  end;
  procedure QuickSortPrim(L, R : integer);
  var
    DividingItem : integer;
  begin
    {stop the recursion, if needed}
    if (R - L) <= 0 then
      Exit;
    {otherwise, partition about the final element in the set}
    DividingItem := Partition(L, R);
    {recursively quicksort the two subsets either side of the dividing
     element}
    QuicksortPrim(L, pred(DividingItem));
    QuicksortPrim(succ(DividingItem), R);
  end;
begin
  {start it all off}
  QuicksortPrim(aLeft, aRight);
end;

procedure QuickSort(var aItemArray    : array of TSortElement;
                        aLeft, aRight : integer;
                        aLessThan     : TLessFunction);
  function Partition(L, R : integer): integer;
  var
    i, j : integer;
    Last : TSortElement;
    Temp : TSortElement;
  begin
    {set up the indexes}
    i := L;
    j := pred(R);
    {get the partition element}
    Last := aItemArray[R];
    {do forever (we'll break out of the loop when needed)}
    while true do begin
      {find the first element greater than or equal to the partition
       element from the left; note that our partition element will
       stop this loop}
      while aLessThan(aItemArray[i], Last) do
        inc(i);
      {find the first element less than the partition element from the
       right; note the median-of-three algorithm has ensured we have
       a sentinel on the left}
      while not aLessThan(aItemArray[j], Last) do
        dec(j);
      {if we crossed get out of this infinite loop to swap the
       partition element into place}
      if (i >= j) then
        Break;
      {otherwise swap the two out-of-place elements}
      Temp := aItemArray[i];
      aItemArray[i] := aItemArray[j];
      aItemArray[j] := Temp;
      {and continue}
      inc(i);
      dec(j);
    end;
    {swap the partition element into place, return the dividing index}
    aItemArray[R] := aItemArray[i];
    aItemArray[i] := Last;
    Result := i;
  end;
  procedure QuickSortPrim(L, R : integer);
  var
    DividingItem : integer;
    Temp : TSortElement;
    i, j : integer;
  begin
    {if needed, stop the recursion at the cut-off point, and insertion
     sort}
    if (R - L) <= 10 then begin
      for i := succ(L) to R do begin
        Temp := aItemArray[i];
        j := i;
        while (j > L) and aLessThan(Temp, aItemArray[j-1]) do begin
          aItemArray[j] := aItemArray[j-1];
          dec(j);
        end;
        aItemArray[j] := Temp;
      end;
      Exit;
    end;
    {calculate the median-of-three element; for an extra bit of speed,
     put the smallest element of the three in the first position, the
     greatest in the last position, and the median in the last-but-one
     position and partition a smaller subset excluding the first and
     last}
    Temp := aItemArray[(L+R) shr 1];
    aItemArray[(L+R) shr 1] := aItemArray[pred(R)];
    aItemArray[pred(R)] := Temp;
    if not aLessThan(aItemArray[L], aItemArray[pred(R)]) then begin
      Temp := aItemArray[L];
      aItemArray[L] := aItemArray[pred(R)];
      aItemArray[pred(R)] := Temp;
    end;
    if not aLessThan(aItemArray[L], aItemArray[R]) then begin
      Temp := aItemArray[L];
      aItemArray[L] := aItemArray[R];
      aItemArray[R] := Temp;
    end;
    if not aLessThan(aItemArray[pred(R)], aItemArray[R]) then begin
      Temp := aItemArray[R];
      aItemArray[R] := aItemArray[pred(R)];
      aItemArray[pred(R)] := Temp;
    end;
    DividingItem := Partition(succ(L), pred(R));
    {recursively quicksort the two subsets either side of the dividing
     element}
    QuickSortPrim(L, pred(DividingItem));
    QuickSortPrim(succ(DividingItem), R);
  end;
begin
  {start it all off}
  QuickSortPrim(aLeft, aRight);
end;

end.